home *** CD-ROM | disk | FTP | other *** search
/ BMUG Revelations / BMUG Revelations.toast / Programming / Programming Languages / Pocket 6.3 / Extensions / Apple Events / AppleEvents < prev    next >
Text File  |  1993-06-23  |  7KB  |  158 lines
  1. ( Apple Events for Pocket Forth )
  2.  
  3. \ Be sure that you are running this file on a COPY of
  4. \ the Pocket Forth application [not the DA]. Close the
  5. \ window if you need to quit and make a back up copy.
  6.  
  7. \ If this is a backup, press return to continue.
  8. key drop
  9. page forget task decimal  0 28 +md !
  10.  
  11. \ Define Apple Event handlers by using ae: and ;ae. Start the
  12. \ definition by putting an event type and class on the stack and
  13. \ calling ae: . Follow with code comprising the handler, then
  14. \ end the handler with ;ae .
  15.  
  16.  
  17. ( get AEDesc handle from an Apple Event )
  18. : ?DESC ( d.key d.type -- desc.handle desc.type -1  or  0 )
  19.     0 >r                                  ( room for error        )
  20.     202 +md 2@ 2>r                        ( the AppleEvent handle )
  21.     2swap 2>r  2>r                        ( keyword and type      )
  22.     here a>r                              ( recieving address     )
  23.     ,$ 303C ,$ 812 ,$ A816 ( AEGetParamDesc: move #$812,d0 _Pack8 )
  24.     r> 0= IF                              ( if there is no error  )
  25.       here 4 + 2@  here 2@  -1            ( get data & leave true )
  26.     ELSE  0 THEN ;                        ( or else leave false   )
  27.  
  28. : -DESC ( addr.where.desc.is.stored -- error ) ( remove desc rec. )
  29.     0 >r  a>r                          ( push room and descriptor )
  30.    ,$ 303C ,$ 0204 ,$ A816 ( AEDisposeDesc: move #$0204,d0 _Pack8 )
  31.     r> ;
  32.  
  33. \ Reply to an Apple Event with a string
  34. : REPLY ( addr count -- )  \ **** USE INSIDE OF A HANDLER ONLY ****
  35.     0 >r                      \ put room for error on rstack
  36.     198 +md 2@ 2>r            \ put the ReplyEvent handle on rstack
  37.     ,s ---- 2>r  ,s TEXT 2>r  \ put keyword and type on rstack
  38.     swap a>r  0 2>r           \ put addr & count on rs from pstack
  39.     ,$ 303C ,$ 0A0F ,$ A816   \ AEPutParamPtr: move #$A0F,d0 _Pack8
  40.     r> drop ;                 \ ignore any error
  41.  
  42.  
  43. ( Do Script Apple Event: misc dosc )
  44. ( Run a 80 character line of text as Pocket Forth code. )
  45. ( This word is installed into the idle handler by the dosc event. )
  46. ( In order to exit into the interpreter the main part of the code )
  47. ( is run outside of the “ae: ... ;ae” pair )
  48.  
  49. 2variable DDATA 4 allot ( d.type d.handle )
  50. variable OIDLE  20 +md @ oidle ! ( hold the old idle routine addr )
  51.  
  52. : DIDLE ( -- ) ( interpret text whose handle is at above variable )
  53.     oidle @  20 +md !          ( first reset idle routine to null )
  54.  
  55.   ( movea.l dd+4[bp],a0 )  ,$ 206B [ ddata 4 + , ]  \ theHandle
  56.   ( _GetHandleSize    )    ,$ A025     \ bytes to move in d0
  57.   ( movea.l [a0],a0   )    ,$ 2050     \ source address in a0
  58.   ( movea.l a4,a1     )    ,$ 224C     \ tib is destination in a1
  59.     78 [ ' min 2+ compile ] drop       \ 78 bytes max in d0
  60.   ( _BlockMove        )    ,$ A02E     \ move data to input stream
  61.  
  62.     ddata -desc                        \ dispose of descriptor
  63.     0= IF                              \ if there is no error
  64.       13 tib 80 + c!                   \ put cr at of end of i.s.
  65.       interpret                        \ jump to interpreter
  66.     THEN ;
  67.  
  68. \ The apple event handler for the 'dosc' (do script) event.
  69. ,s dosc ,s misc  ae:  ( d.eventType d.eventClass -- )
  70.     ,s ---- ,s TEXT ?desc IF        \ get handle to data
  71.       ddata 2!  ddata 4 + 2!        \ store descriptor record
  72.  
  73.       20 +md @  oidle !             \ hold idle routine
  74.       [ ' dIdle literal ] 20 +md !  \ set idle routine to dIdle
  75.                                     \ it will execute on the next
  76.     THEN  ;ae                       \ trip through the event loop
  77.  
  78.  
  79. ( Paste Apple Event: misc past )
  80. ( Like the dosc event, the past event installs part of its handler)
  81. ( into the idle routine, run the next time through the event loop.)  
  82.  
  83. ( temporary idle routine for the Paste handler )
  84. : PIDLE ( -- ) ( run the Paste menu handler )
  85.     oidle @  20 +md !            ( reset idle routine to origonal )
  86.     [ 18 +md @          ( -- menus variable: address of menu list )
  87.       2+ @              ( -- Edit menu )
  88.       8 + @             ( -- Paste handler )
  89.       compile ]         ( compile Paste handler routine for idle  )    
  90.     interpret [                             ( jump to interpreter )
  91.  
  92. ( Paste Apple Event handler )
  93. ,s past ,s misc ae:
  94.     20 +md @  oidle !                  ( hold on to origonal idle )
  95.     [ ' pIdle literal ] 20 +md !      ( set idle routine to above )
  96.   ;ae
  97.  
  98.  
  99. \ Message is a defining word for setting up strings for REPLYing
  100. : MESSAGE"  \ compiling: ( -- ) enclose subsequent quoted string
  101.     CREATE  34 word here  c@ 1+ dup 2 mod +  allot
  102.     DOES>  count ;  \ runtime action: ( -- addr count )
  103.  
  104. message" SERROR Empty stack."
  105. message" UERROR Unknown type."
  106.  
  107. \ represent numbers as strings
  108. : D$ ( d -- addr count ) \ convert double number to string
  109.     depth 1 > IF  swap over dabs <# #s sign #>
  110.     ELSE serror THEN ;
  111. : F$ ( f -- addr count )
  112.     depth 4 > IF
  113.       @pen 2>r  10 +md @ >r  30000 10 +md ! \ move pen offscreen
  114.       3000 3000 !pen f.         \ print float: string is at here
  115.       r> 10 +md !  2r> !pen    \ return pen to origonal position
  116.       here count
  117.     ELSE serror THEN ;
  118. : I$ ( n -- addr count ) depth IF s>d d$ ELSE serror THEN ;
  119. : S$ ( addr -- addr+1 count ) depth IF count ELSE serror THEN ;
  120.  
  121. variable DTYPE 4 allot  4 dtype !  \ length is allways 4
  122. : ?DTYPE ( d -- flag )  \ true if d = dtype+2
  123.     dtype 2+ 2@  dnegate d+ + 0= ;
  124.   
  125.  
  126. \ Evaluate Apple Event: ( misc,eval )
  127. \ From HyperCard:       request 'float' of program 'Pocket Forth'
  128. \ Or from Frontier:     pf.request("float")
  129.  
  130. \ misc,eval takes data from the stack and returns it in various
  131. \ forms depending on the ---- parameter.
  132. \    FLOA = floating point number
  133. \    SHOR = 16 bit integer
  134. \    LONG = 32 bit integer
  135. \    STRI = pascal type string
  136.  
  137. ( The apple event handler for the 'eval' event. )
  138. ,s eval ,s misc  ae:
  139.     ,s ---- ,s TEXT ?desc IF     \ if there is no error
  140.  
  141.       2drop  dtype 2+ a>r          \ hold addr on rstack
  142.       ,$ 7004 ( moveq.l #4,d0    )  \ bytes to move in d0
  143.       ,$ 205E ( movea.l [ps]+,a0 )   \ handle in a0
  144.       ,$ 2050 ( movea.l [a0],a0  )    \ source address in a0
  145.       ,$ 225F ( movea.l [sp]+,a1 )     \ destination in a1
  146.       ,$ A02E ( _BlockMove )            \ move data to here
  147.       dtype 1+ upper                     \ move it to dtype
  148.       ,s SHOR ?dtype IF       i$  ELSE    \ short requested
  149.         ,s LONG ?dtype IF     d$  ELSE     \ long requested
  150.           ,s FLOA ?dtype IF   f$  ELSE      \ float requested
  151.             ,s STRI ?dtype IF s$  ELSE       \ string requested
  152.                              uerror           \ other request
  153.       THEN THEN THEN THEN  reply  THEN ;ae
  154.  
  155.  
  156. : task ; ( protect this from "forget task" )
  157. -1 28 +md !  save bye
  158.